unit DelphiGrammar_Test;

interface

uses
  SysUtils,
  FormalGrammars,
  JvUtils,
  DelphiGrammar,
  UnitTest;

procedure C(const T: ITestingContext; const L: ILexeme; const okArgs: array of string; const wrongArgs: array of string);

implementation

procedure C(const T: ITestingContext; const L: ILexeme; const okArgs: array of string; const wrongArgs: array of string);
var
  g: IGrammar;
  i: string;
  e: IMatchError;
  r: IMatchSuccess;
begin
  g := Grammar(L);
  for i in okArgs do
  begin
    if not g.Apply(i, e, r) then
      T[False, e.GetErrorMessage + ':' + IntToStr(e.GetPosition) + ' by ' +
        IntToStr(e.GetLabel) + sLineBreak + 'Cannot understand: "' + GetWordOnPos(i, e.GetPosition) + '"' + sLineBreak +
        'Target: ' + sLineBreak + i];
  end;
  for i in wrongArgs do
  begin
    if g.Apply(i, e, r) then
      T[False, 'Lexeme ' + L.ToString + ' must not be applicable to: ' + i]; 
  end;
end;

procedure TestString(const T: ITestingContext);
begin
  C(t, _String,
  [
    '''asdfa''',
    ''' asdfasf '' + ''as saf asf  '''
  ],
  [
    ''
  ]);
end;

procedure TestFreeSpace(const t: ITestingContext);
begin
  C(t, f,
  [
    ' ',
    '{a}',
    '  //asdfa '#13#10,
    #13#10,
    '{asdfasd{ asfa  asdf # 234134 asdf '#10'}'
  ],
  [
    ''
  ]);
end;

procedure TestNumbers(const t: ITestingContext);
begin
  C(t, Number, [
    '5',
    '-234251351',
    '+124.34',
    '55552341',
    '3.14'
  ],
  [
    '--1',
    '1.1.1',
    '.',
    '',
    'd',
    '.0',
    '6.'
  ]);
end;

procedure TestIdent(const t: ITestingContext);
begin
  C(t, Ident, [
    'A123',
    '_',
    'a',
    'abcadf_1',
    '123' // Yes it identifier too
  ],
  [
    'a b',
    ' ',
    ''
  ]);
end;

procedure TestTypeID(const t: ITestingContext);
begin
  C(t, TypeId, [
    'u_Unit1.Identifier'
  ],
  [
    'u_Unit1.Unit2.Id1',
    ' value1',
    ' ',
    ''
  ]);
end;

procedure TestIdentList(const t: ITestingContext);
begin
  C(t, IdentList, [
    'a',
    'a, b, c, d',
    'a    ,b   ,   d',
    'a1,b2,c3'
  ],
  [
    ',',
    'a, b,',
    'a b'
  ]);
end;

procedure TestContainsClause(const t: ITestingContext);
begin
  C(t, ContainsClause,
  [
    'contains a, b, c;',
    'contains'#10#13'a,b,c   ;'
  ],
  [
  ]);
end;

procedure TestInterfaceHeritage(const t: ITestingContext);
begin
  C(t, InterfaceHeritage,
  [
    '(TObject, IInteface)',
    '(   TMyClass )',
    '( TType, IInterface , IList)'
  ],
  [
  ]);
end;

procedure TestSubrangeType(const t: ITestingContext);
begin
  C(t, SubrangeType,
  [
    '34..345',
    '3 + 5 .. 123 - 5'
  ],
  [
  ]);
end;

procedure TestEnumeratedType(const t: ITestingContext);
begin
  C(t, EnumeratedType,
  [
    '(  tbEnum1 , {comment 1} tbEnum2 // hello world '#13#10')',
    '(enum1)'
  ],
  [
  ]);
end;

procedure TestRecordFieldConstant(const t: ITestingContext);
begin
  C(t, RecordFieldConstant,
  [
    'X : 12',
    'Y:(1)',
    'Val : (3 + 6)',
    'Va: (3, 5)',
    'n: (x : 5; y : (3 * 6, 11 - 3))'
  ],
  [
  ]);
end;

procedure TestUsesClause(const t: ITestingContext);
begin
  C(t, UsesClause,
  [
    'uses a;',
    'uses a , b ;'
  ],
  [
  ]);
end;

procedure TestClassRefType(const t: ITestingContext);
begin
  C(t, ClassRefType,
  [
    'class of TObject',
    'class  of  TList'
  ],
  [
  ]);
end;

procedure TestStringType(const t: ITestingContext);
begin
  C(t, StringType,
  [
    'string',
    'ansistring',
    'widestring',
    'string[3]',
    'string[3 + 2]',
    'string[a + b]'
  ],
  [
  ]);
end;

procedure TestArrayType(const t: ITestingContext);
begin
  C(t, ArrayType,
  [
  ],
  [
  ]);
end;

procedure TestSetType(const t: ITestingContext);
begin
  C(t, SetType,
  [
    'set of Char',
    'set    of Integer'
  ],
  [
  ]);
end;

procedure TestPointerType(const t: ITestingContext);
begin
  C(t, PointerType,
  [
    '^Integer'
  ],
  [
  ]);
end;

procedure TestTerm(const t: ITestingContext);
begin
  C(t, Term,
  [
    '''abac''',
    '1',
    '1 * 2',
    'a',
    'a *  bc'
  ],
  [
  ]);
end;

procedure TestSimpleExpression(const t: ITestingContext);
begin
  C(t, SimpleExpression,
  [
    '+1',
    '-1',
    '1',
    '1-2'
  ],
  [
  ]);
end;

procedure TestSetConstructor(const t: ITestingContext);
begin
  C(t, SetConstructor,
  [
    '[1..2]',
    '[1..a]',
    '[ 1  , 2,4, 6,  1  -  3 + 2  ]',
    '[]'
  ],
  [
    '[',
    ']',
    '1[]',
    '[1 1]'
  ]);
end;

procedure TestExprList(const t: ITestingContext);
begin
  C(t, ExprList,
  [
    '1, 3, 4',
    '1',
    '1 * 5 - b, 1 - a'
  ],
  [
    '',
    ',',
    '1,',
    ',1'
  ]);
end;

procedure TestDesignator(const t: ITestingContext);
begin
  C(t, Designator,
  [
    'abc',
    'abc^.ad',
    'abc^.ad[1 + 3, a]',    
    'abc[1]',
    'unit1.var2[a]^.b'
  ],
  [
    '[]',
    'abc[1',
    ']',
    '.var'
  ]);
end;

procedure TestFactor(const t: ITestingContext);
begin
  C(t, Factor,
  [
    '1',
    '''abasfsd acsdfasdf ''',
    'ab(1)',
    'func(   )',
    'proc(1, a + b, a[1]  )',
    '(1 + 2 - a * b * (c + 2))',
    'True',
    'nil',
    'not True',
    '[1..6]',
    'ltd()',
    'f(1, 2, 3)'
  ],
  [
  ]);
end;

procedure TestSimpleStatement(const t: ITestingContext);
begin
  C(t, SimpleStatement,
  [
    'a:=b',
    'asf := 1 + 3 * 4',
    'procedure1  ( args [  1 ] , l )',
    'goto   label1'
  ],
  [
  ]);
end;

procedure TestStmtList(const t: ITestingContext);
begin
  C(t, StmtList,
  [
    'a := b',
    'a := b;',
    'a := 1; b(1) ;;  c := 2',
    'a := 1; b(1);',
    'a := 1 ;; ; ; b(1);;;'    
  ],
  [
  ]);
end;

procedure TestCompoundStmt(const t: ITestingContext);
begin
  C(t, CompoundStmt,
  [
    'begin a := b end',
    'begin a := b;end',
    'begin a := 2; a := 4    end',
    'begin end',
    'begin a := 2; a := 4; inc(a);  end',
    'begin Inc(b)end'
  ],
  [
  ]);
end;

procedure TestIfStmt(const t: ITestingContext);
begin
  C(t, IfStmt,
  [
    'if a then b := c',
    'if a = 1 then b := 2 else c := 3',
    'if a = 1 * 5 then begin end',
    'if True then begin Inc(b)end else begin end'
  ],
  [
    'if True then begin Inc(b)end; else begin end'  
  ]);
end;

procedure TestCaseSelector(const t: ITestingContext);
begin
  C(t, CaseSelector,
  [
    '1..2: Inc(a)',
    '1   , 2 , 3 : A := B - C',
    '1, 2..ARG_1: begin end'
  ],
  [
  ]);
end;

procedure TestCaseStmt(const t: ITestingContext);
begin
  C(t, GRepeat(
      CaseSelector,
      SemiColon
    ),
  [
    'WM_PAINT..WM_MOVE: Self.Perform(a); WM_DESTROY: Self.Free;'
  ],
  [
  ]);

  C(t, CaseStmt,
  [
    'case a of 1: Inc(b) end',
    'case Length(S) + 1 of WM_PAINT..WM_MOVE: Self.Perform(a); WM_DESTROY: Self.Free; end'
  ],
  [
  ]);
end;

procedure TestOthers(const t: ITestingContext);
begin
  C(t, Comment1,
  [
    '{asdfasd{ asfa  asdf # 234134 asdf '#10'}'
   ],
   [
    '{asdfasd{a } }'
   ]);

  C(t, Comment2,
  [
    '// asdf asdf aweroaijfasefdrie',
    '// asdf asdf aweroaijfasefdrie'#10#13
  ],
  [
    'a// asdf asdf aweroaijfasefdrie'
  ]);

  C(t, ConstExpr,
  [
    '''''',
    '5',
    '6 - 4 + 2'
  ],
  [
  ]);

  C(t, FileType,
  [
    'file of Integer'
  ],
  [
  ]);

  C(t, CaseLabel,
  [
    '34 .. 6',
    '5'
  ],
  [
  ]);

  C(t, InterfaceSection,
  [
    'interface '
  ],
  [
  ]);
  C(t, ImplementationSection,
  [
    'implementation '
  ],
  [
  ]);

  C(t, _Unit,
  [
    'unit testUnit; interface implementation end.',
    '  unit t; interface var i: Integer; implementation end.  ' 
  ],
  [
  ]);
end;

initialization
  RegisterUnitTest(TestString, 'String');
  RegisterUnitTest(TestFreeSpace, 'FreeSpace');
  RegisterUnitTest(TestNumbers, 'Numbers');
  RegisterUnitTest(TestIdent, 'Ident');
  RegisterUnitTest(TestTypeID, 'TypeID');
  RegisterUnitTest(TestIdentList, 'IdentList');
  RegisterUnitTest(TestContainsClause, 'ContainsClause');
  RegisterUnitTest(TestInterfaceHeritage, 'InterfaceHeritage');
  RegisterUnitTest(TestSubrangeType, 'SubrangeType');
  RegisterUnitTest(TestEnumeratedType, 'EnumeratedType');
  RegisterUnitTest(TestRecordFieldConstant, 'RecordFieldConstant');
  RegisterUnitTest(TestUsesClause, 'UsesClause');
  RegisterUnitTest(TestClassRefType, 'ClassRefType');
  RegisterUnitTest(TestStringType, 'StringType');
  RegisterUnitTest(TestArrayType, 'ArrayType');
  RegisterUnitTest(TestSetType, 'SetType');
  RegisterUnitTest(TestPointerType, 'PointerType');
  RegisterUnitTest(TestTerm, 'Term');
  RegisterUnitTest(TestSimpleExpression, 'SimpleExpression');
  RegisterUnitTest(TestSetConstructor, 'SetConstructor');
  RegisterUnitTest(TestExprList, 'ExprList');
  RegisterUnitTest(TestDesignator, 'Designator');
  RegisterUnitTest(TestFactor, 'Factor');
  RegisterUnitTest(TestSimpleStatement, 'SimpleStatement');
  RegisterUnitTest(TestStmtList, 'StmtList');
  RegisterUnitTest(TestCompoundStmt, 'CompoundStmt');
  RegisterUnitTest(TestIfStmt, 'IfStmt');
  RegisterUnitTest(TestCaseSelector, 'CaseSelector');
  RegisterUnitTest(TestCaseStmt, 'CaseStmt');
  RegisterUnitTest(TestOthers, 'Others');

end.
